home *** CD-ROM | disk | FTP | other *** search
/ Gigarom 1 / Gigarom Macintosh Archives (Quantum Leap)(CDRM1080320)(1993).iso / FILES / DEV / I-Z / XLISP.cpt / XLisp ƒ / XLISP folder / pp.lsp < prev    next >
Text File  |  1988-04-21  |  11KB  |  334 lines
  1. ; PP.LSP -- a pretty-printer for XLISP.
  2.  
  3. ; Adapted by Jim Chapman (Bix: jchapman) from a program written originally
  4. ; for IQLISP by Don Cohen.  Copyright (c) 1984, Don Cohen; (c) 1987, Jim
  5. ; Chapman.  Permission for non-commercial use and distribution is hereby 
  6. ; granted.  Modified for XLISP 2.0 by David Betz.
  7.  
  8. ; In addition to the pretty-printer itself, this file contains a few functions
  9. ; that illustrate some simple but useful applications.
  10.  
  11. ; The basic function accepts two arguments:
  12.  
  13. ;      (PP OBJECT STREAM)
  14.  
  15. ; where OBJECT is any Lisp expression, and STREAM optionally specifies the
  16. ; output (default is *standard-output*).
  17.  
  18. ; PP-FILE pretty-prints an entire file.  It is what I used to produce this
  19. ; file (before adding the comments manually).  The syntax is:
  20.  
  21. ;       (PP-FILE "filename" STREAM)
  22.  
  23. ; where the file name must be a string or quoted, and STREAM, again, is the
  24. ; optional output destination.
  25.  
  26. ; PP-DEF works just like PP, except its first argument is assumed to be the
  27. ; name of a function or macro, which is translated back into the original
  28. ; DEFUN or DEFMACRO form before printing.
  29.  
  30.  
  31. ; MISCELLANEOUS USAGE AND CUSTOMIZATION NOTES:
  32.  
  33. ; 1.  The program uses tabs whenever possible for indentation.
  34. ;     This greatly reduces the cost of the blank space.  If your output
  35. ;     device doesn't support tabs, set TABSIZE to NIL -- which is what I
  36. ;     did when I pretty-printed this file, because of uncertainty 
  37. ;     about the result after uploading.
  38.  
  39. ; 2.  Printmacros are used to handle special forms.  A printmacro is not
  40. ;     really a macro, just an ordinary lambda form that is stored on the
  41. ;     target symbol's property list.  The default printer handles the form
  42. ;     if there is no printmacro or if the printmacro returns NIL.
  43.  
  44. ; 3.  Note that all the pretty-printer subfunctions, including the
  45. ;     the printmacros, return the current column position.
  46.  
  47. ; 4.  Miser mode is not fully implemented in this version, mainly because  
  48. ;     lookahead was too slow.  The idea is, if the "normal" way of
  49. ;     printing the current expression would exceed the right margin, then
  50. ;     use a mode that conserves horizontal space.
  51.  
  52. ; 5.  When PP gets to the last 8th of the line and has more to print than
  53. ;     fits on the line, it starts near the left margin.  This is not 
  54. ;     wonderful, but neither are the alternatives.  If you have a better
  55. ;     idea, go for it.
  56.  
  57. ;  6. Storage requirements are about 1450 cells to load.  
  58.  
  59. ;  7. I tested this with XLISP 1.7 on an Amiga.
  60.  
  61. ;(DEFUN SYM-FUNCTION (X)    ;for Xlisp 1.7
  62. ;    (CAR (SYMBOL-VALUE X)))
  63. (DEFUN SYM-FUNCTION (X)        ;for Xlisp 2.0
  64.     (GET-LAMBDA-EXPRESSION (SYMBOL-FUNCTION X)))
  65.  
  66. (SETQ TABSIZE 8)    ;set this to NIL for no tabs
  67.  
  68. (SETQ MAXSIZE 50)    ;for readability, PP tries not to print more
  69.             ;than this many characters on a line
  70.  
  71. (SETQ MISER-SIZE 2)    ;the indentation in miser mode
  72.  
  73. (SETQ MIN-MISER-CAR 4)    ;used for deciding when to use miser mode
  74.  
  75. (SETQ MAX-NORMAL-CAR 9)    ;ditto
  76.  
  77.  
  78. ; The following function prints a file
  79.  
  80. (DEFUN PP-FILE (FILENAME &OPTIONAL STREAMOUT)
  81.     (OR STREAMOUT (SETQ STREAMOUT *STANDARD-OUTPUT*))
  82.     (PRINC "; Listing of " STREAMOUT)
  83.     (PRINC FILENAME STREAMOUT)
  84.     (TERPRI STREAMOUT)
  85.     (TERPRI STREAMOUT)
  86.     (DO* ((FP (OPENI FILENAME)) (EXPR (READ FP) (READ FP)))
  87.          ((NULL EXPR) (CLOSE FP))
  88.       (PP EXPR STREAMOUT)
  89.       (TERPRI STREAMOUT)))
  90.  
  91.  
  92. ; Print a lambda or macro form as a DEFUN or DEFMACRO:
  93.  
  94. (DEFMACRO PP-DEF (WHO &OPTIONAL STREAM)
  95.     `(PP (MAKE-DEF ,WHO) ,STREAM))
  96.  
  97. (DEFMACRO MAKE-DEF (NAME &AUX EXPR TYPE)
  98.     (SETQ EXPR (SYM-FUNCTION NAME))
  99.     (SETQ TYPE
  100.           (CADR (ASSOC (CAR EXPR)
  101.                        '((LAMBDA DEFUN) (MACRO DEFMACRO)))))
  102.     (LIST 'QUOTE
  103.           (APPEND (LIST TYPE NAME) (CDR EXPR))))
  104.  
  105.  
  106.  
  107. ; The pretty-printer high level function:
  108.  
  109. (DEFUN PP (X &OPTIONAL STREAM)
  110.     (OR STREAM (SETQ STREAM *STANDARD-OUTPUT*))
  111.     (PP1 X STREAM 1 80)
  112.     (TERPRI STREAM)
  113.     T)
  114.  
  115. (DEFUN PP1 (X STREAM CURPOS RMARGIN &AUX SIZE POSITION WIDTH)
  116.     (COND ((NOT (CONSP X)) (PRIN1 X STREAM) (+ CURPOS (FLATSIZE X)))
  117.           ((PRINTMACROP X STREAM CURPOS RMARGIN))
  118.           ((AND (> (FLATSIZE X) (- RMARGIN CURPOS))
  119.                 (< (* 8 (- RMARGIN CURPOS)) RMARGIN))
  120.            (SETQ SIZE (+ (/ RMARGIN 8) (- CURPOS RMARGIN)))
  121.            (MOVETO STREAM CURPOS SIZE)
  122.            (SETQ POSITION (PP1 X STREAM SIZE RMARGIN))
  123.            (MOVETO STREAM POSITION SIZE))
  124.           (T (PRINC "(" STREAM)
  125.              (SETQ POSITION
  126.                    (PP1 (CAR X) STREAM (1+ CURPOS) RMARGIN))
  127.              (COND ((AND (>= (SETQ WIDTH (- RMARGIN POSITION))
  128.                              (SETQ SIZE (FLATSIZE (CDR X))))
  129.                          (<= SIZE MAXSIZE))
  130.                     (PP-REST-ACROSS (CDR X) STREAM POSITION RMARGIN))
  131.                    ((CONSP (CAR X))
  132.                     (MOVETO STREAM POSITION CURPOS)
  133.                     (PP-REST (CDR X) STREAM CURPOS RMARGIN))
  134.                    ((> (- POSITION CURPOS) MAX-NORMAL-CAR)
  135.                     (MOVETO STREAM POSITION (+ CURPOS MISER-SIZE))
  136.                     (PP-REST (CDR X) STREAM (+ CURPOS MISER-SIZE) RMARGIN))
  137.                    (T (PP-REST (CDR X) STREAM POSITION RMARGIN))))))
  138.  
  139. ; MOVETO controls indentating and tabbing.
  140.  
  141. (DEFUN MOVETO (STREAM CURPOS GOALPOS)
  142.     (COND ((> CURPOS GOALPOS)
  143.            (TERPRI STREAM)
  144.            (SETQ CURPOS 1)
  145.            (IF TABSIZE
  146.                (DO NIL
  147.                    ((< (- GOALPOS CURPOS) TABSIZE))
  148.                  (PRINC "\t" STREAM)
  149.                  (SETQ CURPOS (+ CURPOS TABSIZE))))))
  150.     (SPACES (- GOALPOS CURPOS) STREAM)
  151.     GOALPOS)
  152.  
  153. (DEFUN SPACES (N STREAM)
  154.     (DOTIMES (I N) (PRINC " " STREAM)))
  155.  
  156. (DEFUN PP-REST-ACROSS (X STREAM CURPOS RMARGIN &AUX POSITION)
  157.     (SETQ POSITION CURPOS)
  158.     (PROG NIL
  159.       LP
  160.       (COND ((NULL X) (PRINC ")" STREAM) (RETURN (1+ POSITION)))
  161.             ((NOT (CONSP X))
  162.              (PRINC " . " STREAM)
  163.              (PRIN1 X STREAM)
  164.              (PRINC ")" STREAM)
  165.              (RETURN (+ 4 POSITION (FLATSIZE X))))
  166.             (T (PRINC " " STREAM)
  167.                (SETQ POSITION
  168.                      (PP1 (CAR X) STREAM (1+ POSITION) RMARGIN))
  169.                (SETQ X (CDR X))
  170.                (GO LP)))))
  171.  
  172. (DEFUN PP-REST (X STREAM CURPOS RMARGIN &AUX POSITION POS2)
  173.     (SETQ POSITION CURPOS)
  174.     (PROG NIL
  175.       LP
  176.       (COND ((NULL X) (PRINC ")" STREAM) (RETURN (1+ POSITION)))
  177.             ((NOT (CONSP X))
  178.              (AND (> (FLATSIZE X) (- (- RMARGIN POSITION) 3))
  179.                   (SETQ POSITION (MOVETO STREAM POSITION CURPOS)))
  180.              (PRINC " . " STREAM)
  181.              (PRIN1 X STREAM)
  182.              (PRINC ")" STREAM)
  183.              (RETURN (+ POSITION 4 (FLATSIZE X))))
  184.             ((AND (NOT (CONSP (CAR X)))
  185.                   (<= (SETQ POS2 (+ 1 POSITION (FLATSIZE (CAR X))))
  186.                       RMARGIN)
  187.                   (<= POS2 (+ CURPOS MAXSIZE)))
  188.              (PRINC " " STREAM)
  189.              (PRIN1 (CAR X) STREAM)
  190.              (SETQ POSITION POS2))
  191.             (T (MOVETO STREAM POSITION (1+ CURPOS))
  192.                (SETQ POSITION
  193.                      (PP1 (CAR X) STREAM (1+ CURPOS) RMARGIN))))
  194.       (COND ((AND (CONSP (CAR X)) (CDR X))
  195.              (SETQ POSITION (MOVETO STREAM POSITION CURPOS))))
  196.       (SETQ X (CDR X))
  197.       (GO LP)))
  198.  
  199.  
  200. ; PRINTMACROP is the printmacro interface routine.  Note that the
  201. ; called function has the same argument list as PP1.  It may either
  202. ; decide not to handle the form, by returning NIL (and not printing)
  203. ; or it may print the form and return the resulting position.
  204.  
  205. (DEFUN PRINTMACROP (X STREAM CURPOS RMARGIN &AUX MACRO)
  206.     (AND (SYMBOLP (CAR X))
  207.          (SETQ MACRO (GET (CAR X) 'PRINTMACRO))
  208.          (APPLY MACRO (LIST X STREAM CURPOS RMARGIN))))
  209.  
  210. ; The remaining forms define various printmacros.
  211.  
  212. (DEFUN PP-BINDING-FORM (X STREAM POS RMAR &AUX CUR)
  213.     (SETQ CUR POS)
  214.     (COND ((AND (>= (- RMAR POS) (FLATSIZE X))
  215.                 (<= (FLATSIZE X) MAXSIZE)) NIL)
  216.           ((> (LENGTH X) 2)
  217.            (PRINC "(" STREAM)
  218.            (PRIN1 (CAR X) STREAM)
  219.            (PRINC " " STREAM)
  220.            (SETQ CUR
  221.                  (PP1 (CADR X)
  222.                       STREAM
  223.                       (+ 2 POS (FLATSIZE (CAR X)))
  224.                       RMAR))
  225.            (MOVETO STREAM CUR (+ POS 1))
  226.            (PP-REST (CDDR X) STREAM (+ POS 1) RMAR))))
  227.  
  228. (DEFUN PP-DO-FORM (X STREAM POS RMAR &AUX CUR POS2)
  229.     (SETQ CUR POS)
  230.     (COND ((AND (>= (- RMAR POS) (FLATSIZE X))
  231.                 (<= (FLATSIZE X) MAXSIZE)) NIL)
  232.           ((> (LENGTH X) 2)
  233.            (PRINC "(" STREAM)
  234.            (PRIN1 (CAR X) STREAM)
  235.            (PRINC " " STREAM)
  236.            (SETQ POS2 (+ 2 POS (FLATSIZE (CAR X))))
  237.            (SETQ CUR (PP1 (CADR X) STREAM POS2 RMAR))
  238.            (MOVETO STREAM CUR POS2)
  239.            (SETQ CUR (PP1 (CADDR X) STREAM POS2 RMAR))
  240.            (MOVETO STREAM CUR (+ POS 1))
  241.            (PP-REST (CDDDR X) STREAM (+ POS 1) RMAR))))
  242.  
  243. (DEFUN PP-DEFINING-FORM (X STREAM POS RMAR &AUX CUR)
  244.     (SETQ CUR POS)
  245.     (COND ((AND (>= (- RMAR POS) (FLATSIZE X))
  246.                 (<= (FLATSIZE X) MAXSIZE)) NIL)
  247.           ((> (LENGTH X) 3)
  248.            (PRINC "(" STREAM)
  249.            (PRIN1 (CAR X) STREAM)
  250.            (PRINC " " STREAM)
  251.            (PRIN1 (CADR X) STREAM)
  252.            (PRINC " " STREAM)
  253.            (SETQ CUR
  254.                  (PP1 (CADDR X)
  255.                       STREAM
  256.                       (+ 3 POS (FLATSIZE (CAR X)) (FLATSIZE (CADR X)))
  257.                       RMAR))
  258.            (MOVETO STREAM CUR (+ 3 POS))
  259.            (PP-REST (CDDDR X) STREAM (+ 3 POS) RMAR))))
  260.  
  261. (PUTPROP 'QUOTE
  262.          '(LAMBDA (X STREAM POS RMARGIN)
  263.             (COND ((AND (CDR X) (NULL (CDDR X)))
  264.                    (PRINC "'" STREAM)
  265.                    (PP1 (CADR X) STREAM (1+ POS) RMARGIN))))
  266.          'PRINTMACRO)
  267.  
  268. (PUTPROP 'BACKQUOTE
  269.          '(LAMBDA (X STREAM POS RMARGIN)
  270.             (COND ((AND (CDR X) (NULL (CDDR X)))
  271.                    (PRINC "`" STREAM)
  272.                    (PP1 (CADR X) STREAM (1+ POS) RMARGIN))))
  273.          'PRINTMACRO)
  274.  
  275. (PUTPROP 'COMMA
  276.          '(LAMBDA (X STREAM POS RMARGIN)
  277.             (COND ((AND (CDR X) (NULL (CDDR X)))
  278.                    (PRINC "," STREAM)
  279.                    (PP1 (CADR X) STREAM (1+ POS) RMARGIN))))
  280.          'PRINTMACRO)
  281.  
  282. (PUTPROP 'COMMA-AT
  283.          '(LAMBDA (X STREAM POS RMARGIN)
  284.             (COND ((AND (CDR X) (NULL (CDDR X)))
  285.                    (PRINC ",@" STREAM)
  286.                    (PP1 (CADR X) STREAM (+ POS 2) RMARGIN))))
  287.          'PRINTMACRO)
  288.  
  289. (PUTPROP 'FUNCTION
  290.          '(LAMBDA (X STREAM POS RMARGIN)
  291.             (COND ((AND (CDR X) (NULL (CDDR X)))
  292.                    (PRINC "#'" STREAM)
  293.                    (PP1 (CADR X) STREAM (+ POS 2) RMARGIN))))
  294.          'PRINTMACRO)
  295.  
  296. (PUTPROP 'PROG
  297.          'PP-BINDING-FORM
  298.          'PRINTMACRO)
  299.  
  300. (PUTPROP 'PROG*
  301.          'PP-BINDING-FORM
  302.          'PRINTMACRO)
  303.  
  304. (PUTPROP 'LET
  305.          'PP-BINDING-FORM
  306.          'PRINTMACRO)
  307.  
  308. (PUTPROP 'LET*
  309.          'PP-BINDING-FORM
  310.          'PRINTMACRO)
  311.  
  312. (PUTPROP 'LAMBDA
  313.          'PP-BINDING-FORM
  314.          'PRINTMACRO)
  315.  
  316. (PUTPROP 'MACRO
  317.          'PP-BINDING-FORM
  318.          'PRINTMACRO)
  319.  
  320. (PUTPROP 'DO 'PP-DO-FORM 'PRINTMACRO)
  321.  
  322. (PUTPROP 'DO*
  323.          'PP-DO-FORM
  324.          'PRINTMACRO)
  325.  
  326. (PUTPROP 'DEFUN
  327.          'PP-DEFINING-FORM
  328.          'PRINTMACRO)
  329.  
  330. (PUTPROP 'DEFMACRO
  331.          'PP-DEFINING-FORM
  332.          'PRINTMACRO)
  333.  
  334.